home *** CD-ROM | disk | FTP | other *** search
/ SunSoft Catalyst CDWARE 1996 May to August / Catalyst CDWARE 1996 May to August.iso / .products / .bin / httpd / Solaris_x86 / catIPX.pl < prev    next >
Perl Script  |  1995-10-25  |  4KB  |  186 lines
  1. #!./perl
  2.  
  3.  
  4. # ------------------------------------------------------------
  5.  
  6. # This script was baseed on the generic_mailer2.pl, by phil hooper (pjh@netcom.com)
  7. # It was modified for the query engine behind the Catalyst Interlink Solaris Product Expo
  8. # Dec 14, 1994 Marc Sacoolas
  9.  
  10. sub get_request {
  11.  
  12.     # Subroutine get_request reads the POST or GET form request from STDIN
  13.     # into the variable  $request, and then splits it into its
  14.     # name=value pairs in the associative array %rqpairs.
  15.     # The number of bytes is given in the environment variable
  16.     # CONTENT_LENGTH which is automatically set by the request generator.
  17.  
  18.     # Encoded HEX values and spaces are decoded in the values at this
  19.     # stage.
  20.  
  21.     # $request will contain the RAW request. N.B. spaces and other
  22.     # special characters are not handler in the name field.
  23.  
  24.     if ($ENV{'REQUEST_METHOD'} eq "POST") {
  25.     read(STDIN, $request, $ENV{'CONTENT_LENGTH'});
  26.     } elsif ($ENV{'REQUEST_METHOD'} eq "GET" ) {
  27.     $request = $ENV{'QUERY_STRING'};
  28.     }
  29.  
  30.  
  31.     @names = &url_decode(split(/[&=]/, $request));
  32.     %rqpairs = @names;
  33.  
  34. }
  35.  
  36. sub url_decode {
  37.  
  38. #    Decode a URL encoded string or array of strings 
  39. #        + -> space
  40. #        %xx -> character xx
  41.  
  42.  
  43.     foreach (@_) {
  44.     tr/+/ /;
  45.     s/%(..)/pack("c",hex($1))/ge;
  46.     }
  47.     @_;
  48. }
  49.  
  50. sub html_header {
  51.  
  52.     # Subroutine html_header sends to Standard Output the necessary
  53.     # material to form an HHTML header for the document to be
  54.     # returned, the single argument is the TITLE field.
  55.  
  56.     local($title) = @_;
  57.  
  58.     print "Content-type: text/html\n\n";
  59.     print "<html><head>\n";
  60.     print "<title>$title</title>\n";
  61.     print "</head>\n<body>\n";
  62. }
  63.  
  64. sub html_trailer {
  65.  
  66.     # subroutine html_trailer sends the trailing material to the HTML
  67.     # on STDOUT.
  68.  
  69.     local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst)
  70.     = gmtime;
  71.  
  72.     local($mname) = ("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul",
  73.              "Aug", "Sep", "Oct", "Nov", "Dec")[$mon];
  74.     local($dname) = ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri",
  75.              "Sat")[$wday]; 
  76.  
  77.     print "<p>\nGenerated by: <var>$0</var><br>\n";
  78.     print "Date: $hour:$min:$sec UT on $dname $mday $mname $year.<p>\n";
  79.     print "</body></html>\n";
  80. }
  81.  
  82. # --------- Everything above here is generic ---------
  83.  
  84. # Define fairly-constants
  85.  
  86.  
  87. #
  88. # Get the input, output header
  89. #
  90.  
  91. &get_request;
  92.  
  93.  
  94. #
  95. # make sure nobody tries to execute a subshell
  96. #
  97.  
  98. $rqpairs{'mailto'} =~ s/~!/ ~!/g;
  99.  
  100. #
  101. # check for REQUIRED keyword.  Set flag if value is required
  102. # but not provided, then put up a page and forget about sending
  103. # query.  The REQUIRED keyword was still used to insure a
  104. # key word entry. 
  105. #
  106.  
  107. @check_reqs = @names;
  108. for $i (0..$#check_reqs){
  109.     $name = shift(@check_reqs);
  110.     $value = shift(@check_reqs);
  111.  
  112.     if ($name =~ /REQUIRED/) {
  113.         if ($value eq "") {
  114.             $bad = $name;
  115.             $bad =~ s/\s*REQUIRED\s*//;
  116.         push(@missing, $bad);
  117.     }
  118.     }
  119. }
  120.  
  121.  
  122. if ($#missing >= 0) {
  123.     &html_header('Catalyst CDware');
  124.     print "<HR>\n";
  125.     print "<H3>Please provide a key word for your query.</H3>\n";
  126.     print "<HR>\n";
  127.     print "<H3>Go back and try again</H3>\n";
  128.  
  129.     &html_trailer;
  130.     exit 0;
  131. }
  132.  
  133. #
  134. # place keyword in the environment in hopes that it can be inherited
  135. # by it's child csh
  136. #
  137. $keyword = $rqpairs{'KEYWORD'} ;
  138. $install = $rqpairs{'install'} ;
  139. $testdrive = $rqpairs{'testdrive'} ;
  140. $ostype = $rqpairs{'ostype'} ;
  141. #
  142. # see if "ALL" or "" with no filters was selected
  143. #
  144. if ( $keyword eq "ALL" && $ostype eq "OS Type" && $install eq "" && $testdrive eq "" ) {
  145.     print "Location: file:///tmp/httpd/.products/.categories/companies.html\n\n";
  146.     exit 0;
  147. }
  148. #
  149. # settle for file transfer for now, 12-14-94, change later
  150. #
  151. open (QUERY,">/tmp/httpd/tmp");
  152. print QUERY "$keyword^";
  153. print QUERY "$install^";
  154. print QUERY "$testdrive^";
  155. print QUERY "$ostype^";
  156. close (QUERY) ;
  157.  
  158.  
  159. #
  160. # launch query results page generater
  161. #
  162. open (SORT,"|./catIPX.csh /tmp/perl.log") ;
  163. close (SORT) ;
  164.  
  165. #
  166. # if only one, csh will deposite file to go to
  167. #
  168. if ( -e "/tmp/httpd/only_one" ) {
  169.  
  170. open (ONLY,"/tmp/httpd/top");
  171. while (<ONLY>) {
  172.         $line = $_;
  173.         @fields = split(/\^/,$_);
  174. }
  175. close (OPEN);
  176. unlink ("/tmp/httpd/only_one");
  177.  
  178. #print "Location: http://localhost:7999/@fields[2]\n\n";
  179. print "Location: file:///tmp/httpd/.products/@fields[2]/index.html\n\n";
  180. } 
  181. #
  182. # display page
  183. #
  184. print "Location: file:///tmp/httpd/tmppage.html\n\n";
  185.  
  186.